perm filename LISP.LSP[E82,JMC] blob
sn#678292 filedate 1982-09-15 generic text, type C, neo UTF8
COMMENT ā VALID 00004 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 test for some features
C00016 00003
C00018 00004 (defmacro restore (vals . vars)
C00019 ENDMK
Cā;
;;; test for some features
;bfun
(defun ok (sq list) (ok1 sq list 1))
(defun ok1 (sq list n)
(or (null list)
(and (ok2 sq (car list)n)
(ok1 sq (cdr list) (1+ n)))))
(defun ok2 (sq sq1 delta) (not (or (= sq sq1)
(= sq (+ sq1 delta))
(= sq (- sq1 delta)) )))
(defun makedo (n m s1)
(subst n 'n
((lambda (s)
(if (= m n)
(subst (makedo n (1- m) s)
'd
(subst s 'i
'(do ((i 1 (1+ i))
(occ nil)
(sols nil))
((> i n) sols)
(if (ok i occ)
d))))
(subst s 'i
(subst (if (= m 1)
'(setq sols (cons (cons i occ) sols))
(makedo n (1- m) s))
'd
(subst s1 's1
'(do ((i 1 (1+ i))
(occ (cons s1 occ)))
((> i n) sols)
(if (ok i occ) d)))))
))
(gensym))
))
(makedo 4 4 'lose)
;efun
(do ((i1 1 (1+ i1))
(occ nil)
(sols nil))
((> i1 4) sols)
(if (ok i1 occ)
(do ((i2 1 (1+ i2))
(occ (cons i1 occ)))
((> i2 4))
(if (ok i2 occ)
(do ((i3 1 (1+ i3))
(occ (cons i2 occ)))
((> i3 4))
(if (ok i3 occ)
(do ((i4 1 (1+ i4))
(occ (cons i3 occ)))
((> i4 4))
(if (ok i4 occ)
(setq sols (cons (cons i4 occ) sols))
))))))))
(grindef makedo)
(DEFUN MAKEDO (N M S1)
((LAMBDA (S)
(IF
(= M N)
(SUBST (MAKEDO N (1- M) S1)
'D
(SUBST S
'I
'(DO ((I 1 (1+ I)) (OCC NIL) (SOLS NIL))
((> I 4) SOLS)
(IF (OK I OCC) D))))
(SUBST S
'I
(SUBST (IF (= M 0)
'(SETQ SOLS (CONS (CONS S1 OCC) SOLS))
(MAKEDO N (1- M) S1))
'D
'(DO ((I 1 (1+ I)) (OCC (CONS I OCC)))
((> I 4) SOLS)
(IF (OK I OCC) D))))))
(GENSYM)))
*
;end
OK
OK1
OK2
MAKEDO
(DO ((G0015 1 (1+ G0015)) (OCC NIL) (SOLS NIL)) ((> G0015 4) SOLS) (IF
(OK G0015 OCC) (DO ((G0016 1 (1+ G0016)) (OCC (CONS G0015 OCC))) ((> G0016
4) SOLS) (IF (OK G0016 OCC) (DO ((G0017 1 (1+ G0017)) (OCC (CONS G0016
OCC))) ((> G0017 4) SOLS) (IF (OK G0017 OCC) (DO ((G0018 1 (1+ G0018))
(OCC (CONS G0017 OCC))) ((> G0018 4) SOLS) (IF (OK G0018 OCC) (SETQ SOLS
(CONS (CONS G0018 OCC) SOLS))))))))))
((2 4 1 3) (3 1 4 2))
(makedo 5 5 'lose)
(DO ((G0019 1 (1+ G0019)) (OCC NIL) (SOLS NIL)) ((> G0019 5) SOLS) (IF
(OK G0019 OCC) (DO ((G0020 1 (1+ G0020)) (OCC (CONS G0019 OCC))) ((> G0020
5) SOLS) (IF (OK G0020 OCC) (DO ((G0021 1 (1+ G0021)) (OCC (CONS G0020
OCC))) ((> G0021 5) SOLS) (IF (OK G0021 OCC) (DO ((G0022 1 (1+ G0022))
(OCC (CONS G0021 OCC))) ((> G0022 5) SOLS) (IF (OK G0022 OCC) (DO ((G0023
1 (1+ G0023)) (OCC (CONS G0022 OCC))) ((> G0023 5) SOLS) (IF (OK G0023
OCC) (SETQ SOLS (CONS (CONS G0023 OCC) SOLS))))))))))))
((2 4 1 3 5) (3 1 4 2 5) (1 3 5 2 4) (2 5 3 1 4) (1 4 2 5 3) (5 2 4 1
3) (4 1 3 5 2) (5 3 1 4 2) (3 5 2 4 1) (4 2 5 3 1))
(setq base (setq ibase 10.))
10.
(makedo 8 8 'lose)
(DO ((G0024 1. (1+ G0024)) (OCC NIL) (SOLS NIL)) ((> G0024 8.) SOLS) (IF
(OK G0024 OCC) (DO ((G0025 1. (1+ G0025)) (OCC (CONS G0024 OCC))) ((> G0025
8.) SOLS) (IF (OK G0025 OCC) (DO ((G0026 1. (1+ G0026)) (OCC (CONS G0025
OCC))) ((> G0026 8.) SOLS) (IF (OK G0026 OCC) (DO ((G0027 1. (1+ G0027))
(OCC (CONS G0026 OCC))) ((> G0027 8.) SOLS) (IF (OK G0027 OCC) (DO ((G0028
1. (1+ G0028)) (OCC (CONS G0027 OCC))) ((> G0028 8.) SOLS) (IF (OK G0028
OCC) (DO ((G0029 1. (1+ G0029)) (OCC (CONS G0028 OCC))) ((> G0029 8.) SOLS)
(IF (OK G0029 OCC) (DO ((G0030 1. (1+ G0030)) (OCC (CONS G0029 OCC))) ((>
G0030 8.) SOLS) (IF (OK G0030 OCC) (DO ((G0031 1. (1+ G0031)) (OCC (CONS
G0030 OCC))) ((> G0031 8.) SOLS) (IF (OK G0031 OCC) (SETQ SOLS (CONS (CONS
G0031 OCC) SOLS))))))))))))))))))
(length
'((5. 7. 2. 6. 3. 1. 4. 8.) (4. 7. 5. 2. 6. 1. 3. 8.) (6. 4. 7. 1. 3. 5.
2. 8.) (6. 3. 5. 7. 1. 4. 2. 8.) (4. 2. 8. 6. 1. 3. 5. 7.) (5. 3. 1. 6.
8. 2. 4. 7.) (6. 3. 1. 8. 5. 2. 4. 7.) (4. 6. 1. 5. 2. 8. 3. 7.) (4. 2.
5. 8. 6. 1. 3. 7.) (5. 8. 4. 1. 3. 6. 2. 7.) (6. 3. 5. 8. 1. 4. 2. 7.)
(5. 2. 4. 6. 8. 3. 1. 7.) (3. 5. 7. 1. 4. 2. 8. 6.) (3. 5. 2. 8. 1. 7.
4. 6.) (8. 2. 5. 3. 1. 7. 4. 6.) (3. 1. 7. 5. 8. 2. 4. 6.) (3. 7. 2. 8.
5. 1. 4. 6.) (5. 2. 8. 1. 4. 7. 3. 6.) (4. 1. 5. 8. 2. 7. 3. 6.) (5. 1.
8. 4. 2. 7. 3. 6.) (7. 2. 4. 1. 8. 5. 3. 6.) (8. 2. 4. 1. 7. 5. 3. 6.)
(7. 4. 2. 5. 8. 1. 3. 6.) (5. 7. 2. 4. 8. 1. 3. 6.) (4. 2. 8. 5. 7. 1.
3. 6.) (3. 5. 8. 4. 1. 7. 2. 6.) (4. 8. 5. 3. 1. 7. 2. 6.) (4. 7. 3. 8.
2. 5. 1. 6.) (3. 6. 2. 7. 1. 4. 8. 5.) (7. 2. 6. 3. 1. 4. 8. 5.) (2. 6.
8. 3. 1. 4. 7. 5.) (4. 8. 1. 3. 6. 2. 7. 5.) (8. 4. 1. 3. 6. 2. 7. 5.)
(6. 3. 1. 8. 4. 2. 7. 5.) (3. 6. 8. 2. 4. 1. 7. 5.) (2. 4. 6. 8. 3. 1.
7. 5.) (2. 6. 1. 7. 4. 8. 3. 5.) (4. 6. 8. 2. 7. 1. 3. 5.) (7. 4. 2. 8.
6. 1. 3. 5.) (6. 3. 7. 4. 1. 8. 2. 5.) (3. 8. 4. 7. 1. 6. 2. 5.) (1. 6.
8. 3. 7. 4. 2. 5.) (7. 1. 3. 8. 6. 4. 2. 5.) (4. 2. 7. 3. 6. 8. 1. 5.)
(6. 3. 7. 2. 4. 8. 1. 5.) (3. 7. 2. 8. 6. 4. 1. 5.) (6. 2. 7. 1. 3. 5.
8. 4.) (3. 6. 2. 7. 5. 1. 8. 4.) (5. 7. 2. 6. 3. 1. 8. 4.) (2. 8. 6. 1.
3. 5. 7. 4.) (8. 3. 1. 6. 2. 5. 7. 4.) (6. 1. 5. 2. 8. 3. 7. 4.) (3. 6.
2. 5. 8. 1. 7. 4.) (2. 5. 7. 1. 3. 8. 6. 4.) (5. 3. 1. 7. 2. 8. 6. 4.)
(7. 3. 8. 2. 5. 1. 6. 4.) (7. 5. 3. 1. 6. 8. 2. 4.) (6. 3. 1. 7. 5. 8.
2. 4.) (3. 6. 8. 1. 5. 7. 2. 4.) (1. 5. 8. 6. 3. 7. 2. 4.) (5. 1. 8. 6.
3. 7. 2. 4.) (7. 3. 1. 6. 8. 5. 2. 4.) (2. 7. 3. 6. 8. 5. 1. 4.) (6. 3.
7. 2. 8. 5. 1. 4.) (5. 2. 6. 1. 7. 4. 8. 3.) (5. 1. 4. 6. 8. 2. 7. 3.)
(6. 4. 1. 5. 8. 2. 7. 3.) (5. 7. 1. 4. 2. 8. 6. 3.) (4. 2. 7. 5. 1. 8.
6. 3.) (2. 5. 7. 4. 1. 8. 6. 3.) (1. 7. 5. 8. 2. 4. 6. 3.) (2. 7. 5. 8.
1. 4. 6. 3.) (4. 8. 1. 5. 7. 2. 6. 3.) (5. 8. 4. 1. 7. 2. 6. 3.) (4. 7.
1. 8. 5. 2. 6. 3.) (6. 2. 7. 1. 4. 8. 5. 3.) (6. 8. 2. 4. 1. 7. 5. 3.)
(1. 7. 4. 6. 8. 2. 5. 3.) (6. 4. 7. 1. 8. 2. 5. 3.) (6. 4. 2. 8. 5. 7.
1. 3.) (4. 7. 5. 3. 1. 6. 8. 2.) (3. 6. 4. 1. 8. 5. 7. 2.) (4. 1. 5. 8.
6. 3. 7. 2.) (5. 7. 4. 1. 3. 8. 6. 2.) (5. 3. 8. 4. 7. 1. 6. 2.) (3. 6.
8. 1. 4. 7. 5. 2.) (4. 6. 8. 3. 1. 7. 5. 2.) (5. 7. 1. 3. 8. 6. 4. 2.)
(3. 6. 4. 2. 8. 5. 7. 1.) (3. 5. 2. 8. 6. 4. 7. 1.) (5. 2. 4. 7. 3. 8.
6. 1.) (4. 2. 7. 3. 6. 8. 5. 1.))
)
92.
(makedo 7 7 nil)
(DO ((G0032 1. (1+ G0032)) (OCC NIL) (SOLS NIL)) ((> G0032 7.) SOLS) (IF
(OK G0032 OCC) (DO ((G0033 1. (1+ G0033)) (OCC (CONS G0032 OCC))) ((> G0033
7.) SOLS) (IF (OK G0033 OCC) (DO ((G0034 1. (1+ G0034)) (OCC (CONS G0033
OCC))) ((> G0034 7.) SOLS) (IF (OK G0034 OCC) (DO ((G0035 1. (1+ G0035))
(OCC (CONS G0034 OCC))) ((> G0035 7.) SOLS) (IF (OK G0035 OCC) (DO ((G0036
1. (1+ G0036)) (OCC (CONS G0035 OCC))) ((> G0036 7.) SOLS) (IF (OK G0036
OCC) (DO ((G0037 1. (1+ G0037)) (OCC (CONS G0036 OCC))) ((> G0037 7.) SOLS)
(IF (OK G0037 OCC) (DO ((G0038 1. (1+ G0038)) (OCC (CONS G0037 OCC))) ((>
G0038 7.) SOLS) (IF (OK G0038 OCC) (SETQ SOLS (CONS (CONS G0038 OCC) SOLS))))))))))))))))
(length
'((2. 4. 6. 1. 3. 5. 7.) (3. 6. 2. 5. 1. 4. 7.) (4. 1. 5. 2. 6. 3. 7.)
(5. 3. 1. 6. 4. 2. 7.) (2. 5. 3. 1. 7. 4. 6.) (1. 3. 5. 7. 2. 4. 6.) (2.
5. 1. 4. 7. 3. 6.) (2. 4. 1. 7. 5. 3. 6.) (2. 5. 7. 4. 1. 3. 6.) (3. 7.
4. 1. 5. 2. 6.) (4. 2. 7. 5. 3. 1. 6.) (4. 1. 3. 6. 2. 7. 5.) (3. 1. 6.
4. 2. 7. 5.) (7. 2. 4. 6. 1. 3. 5.) (1. 4. 7. 3. 6. 2. 5.) (3. 7. 2. 4.
6. 1. 5.) (2. 6. 3. 7. 4. 1. 5.) (3. 1. 6. 2. 5. 7. 4.) (1. 5. 2. 6. 3.
7. 4.) (2. 7. 5. 3. 1. 6. 4.) (6. 1. 3. 5. 7. 2. 4.) (7. 3. 6. 2. 5. 1.
4.) (5. 7. 2. 6. 3. 1. 4.) (6. 2. 5. 1. 4. 7. 3.) (5. 1. 6. 4. 2. 7. 3.)
(7. 4. 1. 5. 2. 6. 3.) (1. 6. 4. 2. 7. 5. 3.) (5. 7. 2. 4. 6. 1. 3.) (4.
7. 5. 2. 6. 1. 3.) (4. 6. 1. 3. 5. 7. 2.) (5. 1. 4. 7. 3. 6. 2.) (6. 3.
1. 4. 7. 5. 2.) (6. 4. 7. 1. 3. 5. 2.) (6. 3. 7. 4. 1. 5. 2.) (7. 5. 3.
1. 6. 4. 2.) (6. 3. 5. 7. 1. 4. 2.) (3. 5. 7. 2. 4. 6. 1.) (4. 7. 3. 6.
2. 5. 1.) (5. 2. 6. 3. 7. 4. 1.) (6. 4. 2. 7. 5. 3. 1.))
)
40.
(makedo 6 6 nil)
(DO ((G0039 1. (1+ G0039)) (OCC NIL) (SOLS NIL)) ((> G0039 6.) SOLS) (IF
(OK G0039 OCC) (DO ((G0040 1. (1+ G0040)) (OCC (CONS G0039 OCC))) ((> G0040
6.) SOLS) (IF (OK G0040 OCC) (DO ((G0041 1. (1+ G0041)) (OCC (CONS G0040
OCC))) ((> G0041 6.) SOLS) (IF (OK G0041 OCC) (DO ((G0042 1. (1+ G0042))
(OCC (CONS G0041 OCC))) ((> G0042 6.) SOLS) (IF (OK G0042 OCC) (DO ((G0043
1. (1+ G0043)) (OCC (CONS G0042 OCC))) ((> G0043 6.) SOLS) (IF (OK G0043
OCC) (DO ((G0044 1. (1+ G0044)) (OCC (CONS G0043 OCC))) ((> G0044 6.) SOLS)
(IF (OK G0044 OCC) (SETQ SOLS (CONS (CONS G0044 OCC) SOLS))))))))))))))
((2. 4. 6. 1. 3. 5.) (3. 6. 2. 5. 1. 4.) (4. 1. 5. 2. 6. 3.) (5. 3. 1.
6. 4. 2.))
(defun ok (sq list) (ok1 sq list 1))
(defun ok1 (sq list n)
(or (null list)
(and (ok2 sq (car list)n)
(ok1 sq (cdr list) (1+ n)))))
(defun ok2 (sq sq1 delta) (not (or (= sq sq1)
(= sq (+ sq1 delta))
(= sq (- sq1 delta)) )))
;bfun
(defun makedo (n m s1)
(subst m 'n
((lambda (s)
(if (= m n)
(subst (makedo n (1- m) s)
'd
(subst s 'i
'(do ((i 1 (1+ i))
(occ nil)
(sols nil))
((> i n) sols)
(if (ok i occ)
d))))
(subst s 'i
(subst (if (= m k)
'(setq sols (cons (cons i occ) sols))
(makedo n (1- m) s))
'd
(subst s1 's1
'(do ((i 1 (1+ i))
(occ (cons s1 occ)))
((> i n) sols)
(if (ok i occ) d)))))
))
(gensym))
))
;efun
;end
(MAKEDO 4 4 nil)
;LOSE UNBOUND VARIABLE
;K UNBOUND VARIABLE
(setq k 3)
3
(DO ((G0008 1 (1+ G0008)) (OCC NIL) (SOLS NIL)) ((> G0008 4) SOLS) (IF
(OK G0008 OCC) (DO ((G0009 1 (1+ G0009)) (OCC (CONS G0008 OCC))) ((> G0009
3) SOLS) (IF (OK G0009 OCC) (SETQ SOLS (CONS (CONS G0009 OCC) SOLS))))))
((2 4) (1 4) (1 3) (3 1))
(defmacro restore (vals . vars)
`(mapc #'set ',vars ,vals))
(setq u '(a b c))
(restore u a b c)
a
b
c
RESTORE
(A B C)
(A B C)
A
B
C